home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / A_Class_fo2158187222009.psc / VB xBase 1.1 / CTiming.cls next >
Text File  |  2008-09-10  |  4KB  |  127 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "CTiming"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
  15. Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
  16. ' CTiming - (c) 2004 by Donald Lessau, www.xbeat.net
  17. ' total rewrite of old CTimingPC
  18. ' created: 20040614
  19. ' updated: 20040914
  20.  
  21. Option Explicit
  22.  
  23. ' LARGE_INTEGER is faster than Currency type
  24. ' Currency requires CPU to execute slow floating-point instructions
  25. Private Type LARGE_INTEGER
  26.   Lo As Long
  27.   Hi As Long
  28. End Type
  29.  
  30. Private Declare Function QueryPerformanceCounter Lib "kernel32" ( _
  31.     lpPerformanceCount As LARGE_INTEGER) As Long
  32.  
  33. Private Declare Function QueryPerformanceFrequency Lib "kernel32" ( _
  34.     lpFrequency As LARGE_INTEGER) As Long
  35.  
  36. Private uFreq           As LARGE_INTEGER
  37. Private uStart          As LARGE_INTEGER
  38. Private uEnd            As LARGE_INTEGER
  39. Private uPauseStart     As LARGE_INTEGER
  40.  
  41. Private dPauseDuration  As Double
  42. Private dOverhead       As Double
  43.  
  44. Private fAvailable As Boolean
  45.  
  46. Private Sub Class_Initialize()
  47.   Const overheadLoopCount As Long = 100
  48.   Dim i As Long
  49.   
  50.   ' returns ticks/sec
  51.   If QueryPerformanceFrequency(uFreq) = 0& Then
  52.     
  53.     ' some CPUs do NOT support API QueryPerformanceCounter
  54.     MsgBox "Performance Counter not available", vbExclamation
  55.   
  56.   Else
  57.     
  58.     fAvailable = True
  59.     
  60.     ' determine API overhead
  61.     QueryPerformanceCounter uStart
  62.     For i = 1 To overheadLoopCount
  63.       QueryPerformanceCounter uEnd
  64.     Next
  65.     dOverhead = (CDouble(uEnd) - CDouble(uStart)) / overheadLoopCount
  66.     ' 20040614: AMD Athlon XP 2000+
  67.     ' frequency: 3579545          overhead: ca. 2,92 ticks
  68.     ''Debug.Print "frequency:"; CDouble(uFreq), "overhead:"; dOverhead; "ticks"
  69.     
  70.   End If
  71.   
  72. End Sub
  73.  
  74. Friend Sub TReset()
  75.   dPauseDuration = 0
  76.   QueryPerformanceCounter uStart
  77. End Sub
  78.  
  79. Friend Function Elapsed() As Double
  80. ' return elapsed time in milliseconds
  81.   QueryPerformanceCounter uEnd
  82.   If fAvailable Then
  83.     Elapsed = 1000 * (CDouble(uEnd) - CDouble(uStart) - dOverhead - dPauseDuration) / CDouble(uFreq)
  84.   End If
  85. End Function
  86.  
  87. Friend Function sElapsed() As String
  88. ' returns a nicely formatted string
  89.   sElapsed = Format$(Elapsed, "#,0.000") & " msec"
  90. End Function
  91.  
  92. Friend Sub PauseStart()
  93. ' begin pause
  94.   QueryPerformanceCounter uPauseStart
  95. End Sub
  96. Friend Sub PauseEnd()
  97. ' end pause: pause duration will be subtracted from elapsed time
  98.   QueryPerformanceCounter uEnd
  99.   ' add 2 * dOverhead: the API calls are part of the pause
  100.   dPauseDuration = dPauseDuration + (CDouble(uEnd) - CDouble(uPauseStart)) + 2 * dOverhead
  101. End Sub
  102.  
  103. Friend Sub Wait(dMsec As Double, Optional fDoEvents As Boolean)
  104. ' returns after dMsec milliseconds
  105. ' fDoEvents = False:  total suspend, all CPU blocked
  106.   TReset
  107.   Do
  108.     If fDoEvents Then
  109.       DoEvents
  110.     End If
  111.   Loop While fAvailable And Elapsed < dMsec
  112. End Sub
  113.  
  114. Private Function CDouble(uLi As LARGE_INTEGER) As Double
  115.   Dim Low As Double, High As Double
  116.  
  117.   Low = uLi.Lo
  118.   High = uLi.Hi
  119.   
  120.   If Low < 0 Then Low = 4294967296# + Low + 1
  121.   If High < 0 Then High = 4294967296# + High + 1
  122.   
  123.   CDouble = Low + High * 4294967296#
  124. End Function
  125.  
  126.  
  127.